home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url-cache.el.z / url-cache.el
Encoding:
Text File  |  1998-05-21  |  8.8 KB  |  269 lines
  1. ;;; url-cache.el --- Uniform Resource Locator retrieval tool
  2. ;; Author: wmperry
  3. ;; Created: 1997/10/20 22:18:40
  4. ;; Version: 1.14
  5. ;; Keywords: comm, data, processes, hypermedia
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993-1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. (require 'md5)
  29.  
  30. (defcustom url-cache-directory "~/.w3/cache/"
  31.   "*The directory where cache files should be stored."
  32.   :type 'directory
  33.   :group 'url-file)
  34.  
  35. ;; Cache manager
  36. (defun url-cache-file-writable-p (file)
  37.   "Follows the documentation of file-writable-p, unlike file-writable-p."
  38.   (and (file-writable-p file)
  39.        (if (file-exists-p file)
  40.            (not (file-directory-p file))
  41.          (file-directory-p (file-name-directory file)))))
  42.                 
  43. (defun url-cache-prepare (file)
  44.   "Makes it possible to cache data in FILE.
  45. Creates any necessary parent directories, deleting any non-directory files
  46. that would stop this.  Returns nil if parent directories can not be
  47. created.  If FILE already exists as a non-directory, it changes
  48. permissions of FILE or deletes FILE to make it possible to write a new
  49. version of FILE.  Returns nil if this can not be done.  Returns nil if
  50. FILE already exists as a directory.  Otherwise, returns t, indicating that
  51. FILE can be created or overwritten."
  52.   (cond
  53.    ((url-cache-file-writable-p file)
  54.     t)
  55.    ((file-directory-p file)
  56.     nil)
  57.    (t
  58.     (condition-case ()
  59.     (or (make-directory (file-name-directory file) t) t)
  60.       (error nil)))))
  61.  
  62. (defcustom url-cache-ignored-protocols
  63.   '("www" "about" "https" "mailto")
  64.   "*A list of protocols that we should never cache."
  65.   :type '(repeat (string :tag "Protocol"))
  66.   :group 'url-cache)
  67.  
  68. (defun url-cache-cachable-p (obj)
  69.   ;; return t iff the current buffer is cachable
  70.   (cond
  71.    ((not url-automatic-caching)        ; User doesn't want to cache
  72.     nil)
  73.    ((null obj)                ; Something horribly confused
  74.     nil)
  75.    ((member (url-type obj) url-cache-ignored-protocols)
  76.     ;; We have been told to ignore this type of object
  77.     nil)
  78.    ((and (member (url-type obj) '("file" "ftp")) (not (url-host obj)))
  79.     ;; We never want to cache local files... what's the point?
  80.     nil)
  81.    ((member (url-type obj) '("http" "https"))
  82.     (let* ((status (cdr-safe (assoc "status" url-current-mime-headers)))
  83.        (class (if status (/ status 100) 0)))
  84.       (cond
  85.        ((string-match (eval-when-compile (regexp-quote "?"))
  86.               (url-filename obj))
  87.     nil)
  88.        ((= class 2)
  89.     (memq status '(200)))
  90.        (t nil))))
  91.    (t
  92.     nil)))
  93.  
  94. ;;;###autoload
  95. (defun url-store-in-cache (&optional buff)
  96.   "Store buffer BUFF in the cache"
  97.   (if (not (and buff (get-buffer buff)))
  98.       nil
  99.     (save-excursion
  100.       (and buff (set-buffer buff))
  101.       (if (not (url-cache-cachable-p url-current-object))
  102.       nil
  103.     (let* ((fname (url-cache-create-filename (url-view-url t)))
  104.            (fname-hdr (concat fname ".hdr"))
  105.            (info (mapcar (function (lambda (var)
  106.                      (cons (symbol-name var)
  107.                            (symbol-value var))))
  108.                  '( url-current-content-length
  109.                 url-current-object
  110.                 url-current-isindex
  111.                 url-current-mime-encoding
  112.                 url-current-mime-headers
  113.                 url-current-mime-type
  114.                 ))))
  115.       (cond ((and (url-cache-prepare fname)
  116.               (url-cache-prepare fname-hdr))
  117.          (write-region (point-min) (point-max) fname nil 5)
  118.          (set-buffer (get-buffer-create " *cache-tmp*"))
  119.          (erase-buffer)
  120.          (insert "(setq ")
  121.          (mapcar
  122.           (function
  123.            (lambda (x)
  124.              (insert (car x) " "
  125.                  (cond ((null (setq x (cdr x))) "nil")
  126.                    ((stringp x) (prin1-to-string x))
  127.                    ((listp x) (concat "'" (prin1-to-string x)))
  128.                    ((vectorp x) (prin1-to-string x))
  129.                    ((numberp x) (int-to-string x))
  130.                    (t "'???")) "\n")))
  131.           info)
  132.          (insert ")\n")
  133.          (write-region (point-min) (point-max) fname-hdr nil 5))))))))
  134.     
  135.          
  136. ;;;###autoload
  137. (defun url-is-cached (url)
  138.   "Return non-nil if the URL is cached."
  139.   (let* ((fname (url-cache-create-filename url))
  140.      (attribs (file-attributes fname)))
  141.     (and fname                ; got a filename
  142.      (file-exists-p fname)        ; file exists
  143.      (not (eq (nth 0 attribs) t))    ; Its not a directory
  144.      (nth 5 attribs))))        ; Can get last mod-time
  145.  
  146. (defun url-cache-create-filename-human-readable (url)
  147.   "Return a filename in the local cache for URL"
  148.   (if url
  149.       (let* ((url (if (vectorp url) (url-recreate-url url) url))
  150.          (urlobj (url-generic-parse-url url))
  151.          (protocol (url-type urlobj))
  152.          (hostname (url-host urlobj))
  153.          (host-components
  154.           (cons
  155.            (user-real-login-name)
  156.            (cons (or protocol "file")
  157.              (reverse (split-string (or hostname "localhost")
  158.                         (eval-when-compile
  159.                           (regexp-quote ".")))))))
  160.          (fname    (url-filename urlobj)))
  161.     (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/))
  162.         (setq fname (substring fname 1 nil)))
  163.     (if fname
  164.         (let ((slash nil))
  165.           (setq fname
  166.             (mapconcat
  167.              (function
  168.               (lambda (x)
  169.             (cond
  170.              ((and (= ?/ x) slash)
  171.               (setq slash nil)
  172.               "%2F")
  173.              ((= ?/ x)
  174.               (setq slash t)
  175.               "/")
  176.              (t
  177.               (setq slash nil)
  178.               (char-to-string x))))) fname ""))))
  179.  
  180.     (setq fname (and fname
  181.              (mapconcat
  182.               (function (lambda (x)
  183.                       (if (= x ?~) "" (char-to-string x))))
  184.               fname ""))
  185.           fname (cond
  186.              ((null fname) nil)
  187.              ((or (string= "" fname) (string= "/" fname))
  188.               url-directory-index-file)
  189.              ((= (string-to-char fname) ?/)
  190.               (if (string= (substring fname -1 nil) "/")
  191.               (concat fname url-directory-index-file)
  192.             (substring fname 1 nil)))
  193.              (t
  194.               (if (string= (substring fname -1 nil) "/")
  195.               (concat fname url-directory-index-file)
  196.             fname))))
  197.     (and fname
  198.          (expand-file-name fname
  199.                    (expand-file-name
  200.                 (mapconcat 'identity host-components "/")
  201.                 url-cache-directory))))))
  202.  
  203. (defun url-cache-create-filename-using-md5 (url)
  204.   "Create a cached filename using MD5.
  205.  Very fast if you are in XEmacs, suitably fast otherwise."
  206.   (if url
  207.       (let* ((checksum (md5 url))
  208.          (url (if (vectorp url) (url-recreate-url url) url))
  209.          (urlobj (url-generic-parse-url url))
  210.          (protocol (url-type urlobj))
  211.          (hostname (url-host urlobj))
  212.          (host-components
  213.           (cons
  214.            (user-real-login-name)
  215.            (cons (or protocol "file")
  216.              (nreverse
  217.               (delq nil
  218.                 (split-string (or hostname "localhost")
  219.                       (eval-when-compile
  220.                         (regexp-quote "."))))))))
  221.          (fname    (url-filename urlobj)))
  222.     (and fname
  223.          (expand-file-name checksum
  224.                    (expand-file-name
  225.                 (mapconcat 'identity host-components "/")
  226.                 url-cache-directory))))))
  227.  
  228. (defcustom url-cache-creation-function 'url-cache-create-filename-using-md5
  229.   "*What function to use to create a cached filename."
  230.   :type '(choice (const :tag "MD5 of filename (low collision rate)"
  231.             :value url-cache-create-filename-using-md5)
  232.          (const :tag "Human readable filenames (higher collision rate)"
  233.             :value url-cache-create-filename-human-readable)
  234.          (function :tag "Other"))
  235.   :group 'url-cache)
  236.  
  237. (defun url-cache-create-filename (url)
  238.   (funcall url-cache-creation-function url))
  239.  
  240. ;;;###autoload
  241. (defun url-cache-extract (fnam)
  242.   "Extract FNAM from the local disk cache"
  243.   (set-buffer (get-buffer-create url-working-buffer))
  244.   (erase-buffer)
  245.   (setq url-current-mime-viewer nil)
  246.   (insert-file-contents-literally fnam)
  247.   (load (concat (if (memq system-type '(ms-windows ms-dos emx os2))
  248.             (url-file-extension fnam t)
  249.           fnam) ".hdr") t t)) 
  250.  
  251. ;;;###autoload
  252. (defun url-cache-expired (url mod)
  253.   "Return t iff a cached file has expired."
  254.   (let* ((urlobj (if (vectorp url) url (url-generic-parse-url url)))
  255.      (type (url-type urlobj)))
  256.     (cond
  257.      (url-standalone-mode
  258.       (not (file-exists-p (url-cache-create-filename url))))
  259.      ((string= type "http")
  260.       t)
  261.      ((member type '("file" "ftp"))
  262.       (if (or (equal mod '(0 0)) (not mod))
  263.       (return t)
  264.     (or (> (nth 0 mod) (nth 0 (current-time)))
  265.         (> (nth 1 mod) (nth 1 (current-time))))))
  266.      (t nil))))
  267.  
  268. (provide 'url-cache)
  269.